Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacQForth 1.0 / source / QF Source / QFORTH.S < prev

Wrap

Text File | 1995-03-06 | 25KB | 649 lines

utines ******************************** * * Initialize stacks * INITSTACKS LDA #$FF ; Initialize data stack STA DATSTACK ; Initialize data stack STZ DATITEMS STA RETSTACK ; Initalize runtime return stack STZ RETITEMS STA CMPSTACK ; Initialize compiler stacks STA CM2STACK STZ CMPITEMS STZ CM2ITEMS RTS * * Push number onto compiler stack * PUSHCOMP TXA LDX CMPSTACK STA COMPAREA,X DEX TYA STA COMPAREA,X DEX STX CMPSTACK INC CMPITEMS BEQ :ERROR RTS :ERROR LDA #01 JMP PRTERR * * Pop number from compiler stack * POPCOMP LDA CMPITEMS BEQ :ERROR DEC CMPITEMS LDX CMPSTACK INX LDA COMPAREA,X TAY INX STX CMPSTACK LDA COMPAREA,X TAX RTS :ERROR LDA #02 JMP PRTERR * * Push number onto compiler stack 2 * PUSHCMP2 TXA LDX CM2STACK STA CMP2AREA,X DEX TYA STA CMP2AREA,X DEX STX CM2STACK INC CM2ITEMS BEQ :ERROR RTS :ERROR LDA #01 JMP PRTERR * * Pop number from compiler stack 2 * POPCMP2 LDA CM2ITEMS BEQ :ERROR DEC CM2ITEMS LDX CM2STACK INX LDA CMP2AREA,X TAY INX STX CM2STACK LDA CMP2AREA,X TAX RTS :ERROR LDA #02 JMP PRTERR * * Push number onto data stack * PUSHDATA TXA LDX DATSTACK STA DATAAREA,X DEX TYA STA DATAAREA,X DEX STX DATSTACK INC DATITEMS BEQ :ERROR RTS :ERROR LDA #03 JMP PRTERR * * Pop number from data stack * POPDATA LDA DATITEMS BEQ :ERROR DEC DATITEMS LDX DATSTACK INX LDA DATAAREA,X TAY INX STX DATSTACK LDA DATAAREA,X TAX RTS :ERROR LDA #04 JMP PRTERR * * Push number onto return stack * PUSHRETN TXA LDX RETSTACK STA RETNAREA,X DEX TYA STA RETNAREA,X DEX STX RETSTACK INC RETITEMS BEQ :ERROR RTS :ERROR LDA #05 JMP PRTERR * * Pop number from return stack * POPRETN LDA RETITEMS BEQ :ERROR DEC RETITEMS LDX RETSTACK INX LDA RETNAREA,X TAY INX STX RETSTACK LDA RETNAREA,X TAX RTS :ERROR LDA #06 JMP PRTERR ******************************** * End stack manipulation subroutines ******************************** ******************************** * Start compiler output management subroutines ******************************** * * Set compiler output to scratchpad immediate object area * SETSCR LDA #CSCRATCH STA COUTPUT LDA #/CSCRATCH STA COUTPUT+1 RTS * * Set compiler output to end-of-system * SETCEOS LDA EOSPNTR STA COUTPUT LDA EOSPNTR+1 STA COUTPUT+1 RTS * * Set end of system to compiler otuput * SETEOSC LDA COUTPUT STA EOSPNTR LDA COUTPUT+1 STA EOSPNTR+1 RTS * * Output compiler data * OUTBYTE STA (COUTPUT) INC COUTPUT BNE :SKIPINC INC COUTPUT+1 :SKIPINC RTS ******************************** * End compiler output management subrotuines ******************************** ******************************** * Start vocabulary maintenance subroutines ******************************** * * Linked list node consists of four bytes: * * (Word pointer to next node, null if tail node) + * (word pointer to text) * * * Clear vocabulary * CLRVOCAB LDX #$7F :LOOP STZ HASHTBLL,X STZ HASHTBLH,X DEX BPL :LOOP LDA #LINKLIST STA LISTPNTR LDA #/LINKLIST STA LISTPNTR+1 RTS * * Calculate hash value of word at (WORDPNTR) * CALCHASH LDA WORDPNTR STA PNTR LDA WORDPNTR+1 STA PNTR+1 CALCHSH2 STZ HASH LDY #$00 LDA (PNTR),Y :LOOP EOR HASH STA HASH INY LDA (PNTR),Y CMP #' ' BEQ :FINIS CMP #$0D BNE :LOOP :FINIS LDA HASH AND #$7F STA HASH RTS * * See if word at (WORDPNTR) already exists * * Note: CALCHASH must be called before CHKWORD * CHKWORD LDY HASH LDA HASHTBLL,Y ; See if first link exists ORA HASHTBLH,Y BNE :CHECK CLC ; First link doesn't exist RTS ; so word isn't in vocabulary :CHECK LDA HASHTBLL,Y ; Fetch pointer to linked list STA PNTR LDA HASHTBLH,Y STA PNTR+1 LDY #$01 :OUTER INY ; Fetch pointer to text LDA (PNTR),Y STA PNTR2 INY LDA (PNTR),Y STA PNTR2+1 LDY #$FF ; See if texts are identical :INNER INY LDA (PNTR2),Y CMP #' ' BEQ :END? CMP (WORDPNTR),Y BEQ :INNER BRA :NEXT :END? LDA (WORDPNTR),Y CMP #' ' BEQ :FOUND CMP #$0D BEQ :FOUND :NEXT LDA (PNTR) ; See if pointer to next node exists TAX LDY #$01 LDA (PNTR),Y STX PNTR STA PNTR+1 ORA PNTR BNE :OUTER CLC ; Word not in vocabulary RTS :FOUND INY ; Found, so leave address of routine in LDA (PNTR2),Y ; PNTR and set carry STA PNTR INY LDA (PNTR2),Y STA PNTR+1 RTS * * Add word to vocabulary * * Note: CALCHASH must be called before ADDWORD * ADDWORD LDY HASH ; See if there is initial pointer LDA HASHTBLL,Y ORA HASHTBLH,Y BNE :TRAVERS LDA LISTPNTR ; Create initial pointer STA HASHTBLL,Y LDA LISTPNTR+1 STA HASHTBLH,Y LDY #$01 BRA :CREATE :TRAVERS LDA HASHTBLL,Y ; Must traverse linked list to find STA PNTR ; tail node to tack new node onto LDA HASHTBLH,Y STA PNTR+1 LDY #$01 :LOOP LDA (PNTR) TAX ORA (PNTR),Y BEQ :TAILFND LDA (PNTR),Y STA PNTR+1 STX PNTR BRA :LOOP :TAILFND LDA LISTPNTR STA (PNTR) LDA LISTPNTR+1 STA (PNTR),Y :CREATE LDA #$00 ; Pointer to next node = null STA (LISTPNTR) STA (LISTPNTR),Y LDA PNTR3 INY STA (LISTPNTR),Y LDA PNTR3+1 INY STA (LISTPNTR),Y LDA LISTPNTR ; Move list pointer to next free space CLC ADC #$04 STA LISTPNTR BCC :SKIPINC INC LISTPNTR+1 :SKIPINC RTS * * Forget last defined word * FRGTLAST LDA LISTPNTR ; Throw away last node SEC SBC #$04 STA LISTPNTR BCS :SKIPDEC DEC LISTPNTR+1 :SKIPDEC LDY #$02 ; Set up pointer to word text LDA (LISTPNTR),Y STA PNTR INY LDA (LISTPNTR),Y STA PNTR+1 JSR CALCHSH2 ; Calculate hash value LDX HASH ; Is it initial pointer? LDA HASHTBLL,X STA PNTR TAY LDA HASHTBLH,X STA PNTR+1 CMP LISTPNTR+1 BNE :TRAVERS CPY LISTPNTR BNE :TRAVERS STZ HASHTBLL,X ; Easy to kill initial pointer STZ HASHTBLH,X RTS :TRAVERS LDY #$01 ; Check against next node :LOOP LDA (PNTR) TAX LDA (PNTR),Y CMP LISTPNTR+1 BNE :GONEXT CPX LISTPNTR BNE :GONEXT LDA #$00 ; Kill this link STA (PNTR) STA (PNTR),Y RTS :GONEXT STX PNTR ; Go to next node STA PNTR+1 BRA :LOOP * * List all words * LISTWRDS LDA #$8D ; Skip a line for neatness JSR COUT LDA #LINKLIST ; Start at beginning of list STA PNTR LDA #/LINKLIST STA PNTR+1 LDA #$05 ; Five words per line (4 to 0) STA TEMP :OUTER LDY #$02 ; Fetch pointer to word name LDA (PNTR),Y STA PNTR2 INY LDA (PNTR),Y STA PNTR2+1 LDX #16 ; Print word name LDY #$00 :INNER LDA (PNTR2),Y CMP #$20 BEQ :ENDTEXT CMP #$0D BEQ :ENDTEXT JSR COUT INY DEX BRA :INNER :ENDTEXT TXA ; Justify it to 16 characters BMI :NEXTWRD BEQ :NEXTWRD :TINY LDA #' ' JSR COUT DEX BNE :TINY :NEXTWRD LDA PNTR ; Move PNTR to next node CLC ADC #$04 STA PNTR BCC :SKIPINC INC PNTR+1 :SKIPINC DEC TEMP BNE :NORESET LDA KYBD ; Check for ctrl-S BIT STROBE CMP #$93 BNE :NOTPAUS :PAUSE LDA KYBD BPL :PAUSE BIT STROBE :NOTPAUS LDA #$05 STA TEMP :NORESET LDA PNTR ; See if we're at end of list yet CMP LISTPNTR BNE :OUTER LDA PNTR+1 CMP LISTPNTR+1 BNE :OUTER LDA TEMP ; If we're at end of line, no <CR> CMP #$05 ; otherwise one <CR>s BEQ :NOCR LDA #$8D JMP COUT :NOCR RTS * * Load default system words * LOADWRDS JSR CLRVOCAB LDA #SYSWORDS STA PNTR4 LDA #/SYSWORDS STA PNTR4+1 :LOOP LDA (PNTR4) STA WORDPNTR STA PNTR3 LDY #$01 LDA (PNTR4),Y STA WORDPNTR+1 STA PNTR3+1 ORA WORDPNTR BEQ :FINIS JSR CALCHASH JSR ADDWORD LDA PNTR4 CLC ADC #$02 STA PNTR4 BCC :LOOP INC PNTR4+1 BRA :LOOP :FINIS RTS SYSWORDS DW WORD1 DW WORD2 DW WORD3 DW WORD4 DW WORD5 DW WORD6 DW WORD7 DW WORD8 DW WORD9 DW WORD10 DW WORD11 DW WORD12 DW WORD13 DW WORD14 DW WORD15 DW WORD16 DW WORD17 DW WORD18 DW WORD19 DW WORD20 DW WORD21 DW WORD22 DW WORD23 DW WORD24 DW WORD25 DW WORD26 DW WORD27 DW WORD28 DW WORD29 DW WORD30 DW WORD31 DW WORD32 DW WORD33 DW WORD34 DW WORD35 DW WORD36 DW WORD37 DW WORD38 DW WORD39 DW WORD40 DW WORD41 DW WORD42 DW WORD43 DW WORD44 DW WORD45 DW WORD46 DW WORD47 DW WORD48 DW WORD49 DW WORD50 DW WORD51 DW WORD52 DW WORD53 DW WORD54 DW WORD55 DW WORD56 DW WORD57 DW WORD58 DW WORD59 DW WORD60 DW WORD61 DW WORD62 DW WORD63 DW WORD64 DW WORD65 DW WORD66 DW WORD67 DW WORD68 DW WORD69 DW WORD70 DW WORD71 DW WORD72 DW WORD73 DW WORD74 DW WORD75 DW WORD76 DW WORD77